Transactor/Transactor_12_1986_Transactor_Publishing.d64/func wedge.pal

Commodore BASIC | 2023-02-26 | 10KB | 365 lines

1000 ;
1010 ;function wedge
1020 ;by frank e. digioia
1030 ;11/12/85
1040 ;
1050 * = $c000       ;convenient start
1060 ;
1070 chrget = $0073         ;get byte of text
1080 chr(NULL)t = $0079         ;get same byte
1090 ieval  = $030a         ;evaluation vector
1100 type   = $0d           ;type flag
1110 ;
1120 init   = *             ;initialize routine
1130 lda #<fwedge
1140 sta ieval
1150 lda #>fwedge
1160 sta ieval+1
1170 rts
1180 ;
1190 fwedge = *             ;this is the wedge
1200 lda #$00        ;flag for numeric
1210 sta type        ;set type flag
1220 ;
1230 jsr chrget      ;see what we've (NULL)t
1240 cmp #'$'        ;hex conversionprint
1250 beq jump
1260 cmp #'%'        ;binary conversionprint
1270 beq jump+3
1280 cmp #'@'        ;plot functionprint
1290 beq jump+6
1300 cmp #'#'        ;the # commandprint
1310 beq jump+9
1320 cmp #'!'        ;use the parserprint
1330 beq parser
1340 ;not one of ours
1350 jsr chr(NULL)t      ;set flags again
1360 jmp $ae8d       ;use original routine
1370 ;
1380 jump   = *             ;jump table for fns
1390 jmp hex
1400 jmp bin
1410 jmp xplot
1420 jmp expand
1430 ;
1440 parser = *             ;parse & execute
1450 lda #$00        ;clear all regs
1460 sta count       ;and counter
1470 tax
1480 tay
1490 ;
1500 ploop  iny             ;incr text index
1510 lda table,x     ;get table byte
1520 beq error       ;end of table
1530 inx             ;incr table pointer
1540 cmp ($7a),y     ;cmpare with text
1550 bne next        ;find next word
1560 beq ploop       ;match/keep looking
1570 ;
1580 next   dex             ;bump .x down once
1590 lda table,x     ;end of table wordprint
1600 bpl find        ;no/find end of word
1610 and #$7f        ;yes/mask flag
1620 cmp ($7a),y     ;is it a matchprint
1630 beq found       ;hooray!!!
1640 bne x1          ;(NULL) back for more
1650 ;
1660 find   inx             ;find end of word
1670 lda table,x     ;look for negative
1680 beq error       ;end of table
1690 bpl find        ;keep looking
1700 ;
1710 x1     inx             ;point to next word
1720 inc count       ;word # in table
1730 ldy #$00        ;reset text index
1740 jmp ploop       ;search some more
1750 ;
1760 found  = *             ;execution routine
1770 iny             ;point to next byte
1780 tya             ;update text pointer
1790 clc
1800 adc $7a
1810 sta $7a
1820 bcc *+4
1830 inc $7b
1840 ;
1850 lda count       ;get offset in table
1860 asl a           ;multiply by two
1870 tax             ;use as index
1880 lda adrtab+1,x  ;hi byte adr
1890 pha             ;as return adr hi
1900 lda adrtab,x    ;lo byte adr
1910 pha             ;as return adr lo
1920 rts             ;execute routine
1930 ;
1940 count  .byte $00
1950 error  jmp $af08       ;syntax error
1960 ;
1970 ;data tables -- add your own
1980 ;routine names and addresses
1990 ;here. be sure to add $80 to
2000 ;last character of name and
2010 ;subtract 1 from the address
2020 ;
2030 table  .byte 'mo',$c4,'fra',$c3
2040 .byte  'di',$d6,'dsta',$d4,$00
2050 ;
2060 adrtab .word mod-1,frac-1,div-1,dstat-1
2070 ;
2080 ;
2090 ;function calculation routines
2100 ;
2110 ;dstat function
2120 ;
2130 acptr  = $ffa5         ;get byte from serial port
2140 fa     = $ba           ;device number
2150 sa     = $b9           ;secondary address
2160 wbuf   = $033c         ;buffer for string
2170 talk   = $ffb4         ;tell device to talk
2180 tksa   = $ff96         ;send 2nd adr for talk
2190 untalk = $ffab         ;free serial bus
2200 ;
2210 dstat  = *
2220 ldx #$08        ;device number (disk)
2230 stx fa          ;first address
2240 txa
2250 jsr talk        ;tell drive to speak
2260 lda #$6f        ;channel 15 (or $60)
2270 sta sa          ;secondary address
2280 jsr tksa        ;send it to drive
2290 ldx #$00
2300 ;
2310 dloop  = *             ;read command channel
2320 jsr acptr       ;get byte from drive
2330 sta wbuf,x      ;store character
2340 inx
2350 cmp #$0d        ;carriage returnprint
2360 bne dloop
2370 jsr untalk      ;free serial port
2380 ;
2390 dex             ;forget the <cr>
2400 txa             ;put length in .a
2410 sta len         ;save it
2420 jsr $b47d       ;reserve space for string
2430 ldy len         ;use length for index
2440 ;
2450 dloop2 = *             ;copy string for basic
2460 lda wbuf,y      ;get byte of string
2470 sta ($62),y     ;put in string mem.
2480 dey             ;bump pointer down
2490 bpl dloop2
2500 jmp $b4ca       ;put dscrptr on stack
2510 ;
2520 ;
2530 ;@(row,col) function - plot
2540 ;cursor and return null string
2550 ;
2560 chklft = $aefa         ;check left paren
2570 chkrht = $aef7         ;check right paren
2580 chkcom = $aefd         ;check on comma
2590 getbyt = $b79e         ;get byte into .x
2600 plot   = $fff0         ;plot/fetch cursor
2610 ;
2620 xplot  = *
2630 jsr chrget      ;get next byte
2640 jsr getprm      ;get row/col in x/y
2650 cpx #$19        ;row less than 25print
2660 bcc chky        ;yes/check column
2670 bad    jmp ilegal      ;no/illegal quant.
2680 chky   cpy #$28        ;col less than 40print
2690 bcs bad         ;no/trash it.
2700 clc             ;just for looks
2710 jsr plot        ;plot the cursor
2720 lda #$00        ;set len to zero
2730 jsr $b47d       ;reserve space
2740 jmp $b4ca       ;put descrptr on stack
2750 ;
2760 getprm=*;get (a,b) into .x/.y
2770 jsr chklft      ;check open paren
2780 jsr getbyt      ;get first parm
2790 stx len         ;save it here
2800 jsr chkcom      ;check on comma
2810 jsr getbyt      ;get second byte
2820 txa             ;put in .a
2830 pha             ;keep it safe
2840 jsr chkrht      ;check closing paren
2850 pla             ;retrieve 2nd parm
2860 tay             ;put in .y
2870 ldx len         ;retrieve 1st parm
2880 rts
2890 len    .byte $00
2900 ;
2910 ;
2920 ;the #(lo,hi) command -- convert
2930 ;lo/hi to 16 bit number.
2940 ;
2950 expand = *
2960 jsr chrget      ;get next byte of text
2970 jsr getprm      ;get parms into x/y
2980 stx $63         ;lo byte in $63
2990 sty $62         ;hi byte in $62
3000 ldx #$90        ;set exponent to 15
3010 sec             ;don't invert mantissa
3020 jmp $bc49       ;convert to fac
3030 ;
3040 ;
3050 ;hex/binary conversion routine --
3060 ;this routine converts ascii
3070 ;hex or binary numbers to floating
3080 ;point.
3090 ;
3100 addbyt = $bd7e         ;add .a to fac
3110 ilegal = $b248         ;illegal quantity
3120 oflow  = $b97e         ;overflow error
3130 exp    = $61           ;exponent of fac
3140 ;
3150 hex    lda #$00        ;flag for hex
3160 .byte $2c       ;skip next instr.
3170 bin    lda #$01        ;flag for binary
3180 sta flag        ;save flag
3190 jsr zero        ;set fac to zero
3200 ;
3210 loop   jsr chrget      ;get next char.
3220 beq cdone       ;end of statement
3230 jsr convrt      ;convert from ascii
3240 jsr incexp      ;incr. fac exponent
3250 jsr addbyt      ;add the byte to fac
3260 jmp loop
3270 ;
3280 quit   pla             ;pull return adr.
3290 pla
3300 cdone  jmp chr(NULL)t      ;set flags & rts
3310 ;
3320 ;hex/bin subroutines
3330 ;
3340 zero   = *             ;set fac to zero
3350 lda #$00        ;here's the zero
3360 ldx #$05        ;5 bytes + sign
3370 ;
3380 zilch  sta exp,x       ;zero out byte
3390 dex             ;bump index down
3400 bpl zilch       ;counter roll overprint
3410 rts
3420 ;
3430 convrt = *             ;ascii digit to true value
3440 bcc digit       ;chrget flag/digitprint
3450 ldx flag        ;hex or binaryprint
3460 bne chkerr      ;binary non-digit
3470 cmp #'a'        ;check lower limit
3480 bcc quit        ;less than 'a'
3490 cmp #'g'        ;check upper limit
3500 bcs chkerr      ;bigger than 'f'
3510 sec
3520 sbc #$07        ;account for extra 7
3530 digit  ldx flag        ;hex or binaryprint
3540 beq okay        ;hex/any digit is fine
3550 cmp #'2'        ;bin/check upper limit
3560 bcs err2        ;bigger than 1
3570 okay   sec
3580 sbc #$30        ;convert to true value
3590 rts
3600 ;
3610 chkerr = *             ;check illegal quant.
3620 cmp #$41        ;compare with 'a'
3630 bcc quit        ;less than 'a'
3640 cmp #$5b        ;compare with '['
3650 bcs quit        ;greater than 'z'
3660 err2   jmp ilegal      ;illegal quantity
3670 ;
3680 ;
3690 incexp =  *            ;increment exponent
3700 ldx exp         ;get exponent
3710 beq exit        ;fac=0, don't incr.
3720 pha             ;save byte in .a
3730 ldx flag        ;use flag for offset
3740 lda incr,x      ;get incr in .a
3750 clc
3760 adc exp         ;add exp to incr.
3770 bcs err1        ;overflow error
3780 sta exp         ;update exponent
3790 pla             ;retrieve byte to .a
3800 exit   rts
3810 ;
3820 err1   jmp oflow
3830 incr   .byte $04,$01
3840 flag   .byte $00
3850 ;
3860 ;
3870 ;div/mod/frac -- these routines respectively
3880 ;return the integer-quotient,
3890 ;integer-remainder, or fractional
3900 ;part of the quotient a/b.
3910 ;
3920 exp    = $61           ;adr of exp of fac
3930 facarg = $bc0c         ;copy fac to arg
3940 facmem = $bbd4         ;store fac at adr in (x/y)
3950 mdiv   = $bb0f         ;divide fac by mem
3960 subtrt = $b853         ;subtract fac from arg
3970 mmult  = $ba28         ;mult fac by mem (a/y)
3980 facint = $bccc         ;convert fac to integer
3990 round  = $bc1b         ;round the fac
4000 add5   = $b849         ;add .5 to fac
4010 frmnum = $ad8a         ;get numeric parm into fac
4020 ;
4030 ;
4040 div    = *             ;entry for div
4050 lda #$00        ;flag for div
4060 .byte $2c       ;skip next instr
4070 mod    = *             ;entry for mod
4080 lda #$01        ;flag for mod
4090 .byte $2c       ;skip next instr
4100 frac   = *             ;entry for frac
4110 lda #$ff        ;flag for frac
4120 sta flag        ;set the flag
4130 ;
4140 ;get first parm in fac and 2nd
4150 ;parm in arg.
4160 ;
4170 jsr chklft      ;open parenprint
4180 jsr frmnum      ;get first value
4190 ldx #<temp      ;lo byte of address
4200 ldy #>temp      ;hi byte of address
4210 jsr facmem      ;place in temp
4220 jsr chkcom      ;commaprint
4230 jsr frmnum      ;get 2nd parm
4240 jsr chkrht      ;closing parenprint
4250 ;
4260 ldx #<modlus    ;get adr of modlus
4270 ldy #>modlus    ;in .x/.y
4280 jsr facmem      ;store fac at modlus
4290 ;
4300 lda #<temp      ;adr of 1st parm (lo)
4310 ldy #>temp      ;adr of 1st parm (hi)
4320 jsr mdiv        ;fac = temp/fac
4330 jsr facarg      ;arg = fac
4340 jsr facint      ;fac = int(fac)
4350 ;
4360 ;check flag.  if div function
4370 ;then done, else continue.
4380 ;
4390 lda flag
4400 beq done
4410 ;
4420 lda exp         ;must have exp in .a
4430 jsr subtrt      ;fac = arg - fac
4440 ;
4450 ;check flag.  if frac function
4460 ;then done, else continue.
4470 ;
4480 lda flag
4490 bmi done
4500 ;
4510 lda #<modlus    ;get address of the
4520 ldy #>modlus    ;modulus in .a/.y
4530 jsr mmult       ;fac = fac * modlus
4540 jsr add5        ;add .5 for roundoff
4550 jsr facint      ;truncate garbage
4560 ;
4570 done   jsr round       ;round the fac
4580 rts
4590 ;
4600 modlus * = *+5
4610 temp   * = *+5
4620 ;
4630 .end